perm filename ANIMED.SAI[PUR,LCS] blob
sn#443181 filedate 1979-07-23 generic text, type T, neo UTF8
00100 BEGIN "ANIMED"
00200 REQUIRE "GEOMES.HDR[CMS,LCS]" SOURCE_FILE;
00250 REQUIRE "MN.REL[CMS,LCS]" LOAD_MODULE;
00300 DEFINE MEM="MEMORY";DEFINE α="COMMENT";
00400 DEFINE SUBR="SIMPLE INTEGER PROCEDURE";
00500 STRING STR;REAL FO,RNOF;
00600 INTEGER ATR,CDAD,PDAD,PATR,CATR,NDAD;
00700 INTEGER TF,NFR,NT,TMP,CAMR,POP,DT;
00800 INTEGER CI,WO,CB,CHR,N,I,NOF;
00900 INTEGER CFR,CT,PFR,NAM1,NAM2,CD;
01000 INTERNAL INTEGER FNUM;
01100 SAFE INTEGER ARRAY BLIST[1:200];
01200 SUBR NINK(INTEGER Q);START_CODE HLRZ 1,Q;END;
01300 SUBR PINK(INTEGER Q);START_CODE HRRZ 1,Q;END;
01400
01500 SUBR COPTRM;
01600 START_CODE
01700 HRRZ 1,NFR; MOVE 2,FNUM; CAME 2,(1);
01800 HRRZ 1,PFR; HRRZM 1,CFR; HRRZ 2,CB;
01900 HRRZ 1,6(1); HRLZI 1,-3(1);
02000 HRRZ 2,6(2); HRRI 1,-3(2);
02100 BLT 1,8(2);
02200 END;
02300
02400 SUBR DIFF(INTEGER Q1,Q2);
02500 START_CODE LABEL L1;
02600 HRRZ 1,Q2; HRRZ 2,Q1;
02700 HRRZ 1,6(1); HRRZ 2,6(2);
02800 MOVE 3,-3(1); CAME 3,-3(2); JRST L1;
02900 MOVE 3,-2(1); CAME 3,-2(2); JRST L1;
03000 MOVE 3,-1(1); CAME 3,-1(2); JRST L1;
03100 MOVE 3,(1); CAME 3,(2); JRST L1;
03200 MOVE 3,1(1); CAME 3,1(2); JRST L1;
03300 MOVE 3,2(1); CAME 3,2(2); JRST L1;
03400 MOVE 3,3(1); CAME 3,3(2); JRST L1;
03500 MOVE 3,4(1); CAME 3,4(2); JRST L1;
03600 MOVE 3,5(1); CAME 3,5(2); JRST L1;
03700 MOVE 3,6(1); CAME 3,6(2); JRST L1;
03800 MOVE 3,7(1); CAME 3,7(2); JRST L1;
03900 MOVE 3,8(1); CAME 3,8(2); JRST L1;
04000 HRRZ 2,Q1; SKIPE 3,5(2); CAMN 3,3(1); CAIA;
04100 L1: SKIPA 1,L1; SETZ 1,;
04200 END;
04300
04400 SUBR SEEN(INTEGER B);
04500 START_CODE
04600 LABEL LOOP,DONE,STAR;
04700 HRRZ 1,B; HRRZ 3,N; ADD 3,BLIST;
04800 SKIPE CAMR; HRRZI 1,LOOP;
04900 HRRZ 2,BLIST; JRST STAR;
05000 "α"; 0;
05100 LOOP: ADDI 2,3;
05200 STAR: CAIG 3,1(2); JRST DONE;
05300 MOVE 4,1(2); MOVE 5,2(2);
05400 CAMN 4,-2(1); CAME 5,-1(1);
05500 JRST LOOP; SUB 2,BLIST; AOJ 2,;
05600 SKIPA 1,2;
05700 DONE: SETZ 1,;
05800 END;
00100 SUBR MOVED(INTEGER PF);
00200 BEGIN
00300 IF DAD(CB) THEN RETURN(-1)
00400 ELSE RETURN(DIFF(PF,CB));
00500 END;
00600
00700
00800 SUBR SEEIT(INTEGER D);
00900 BEGIN
01000 IF ¬(CDAD←SEEN(D)) THEN BEGIN
01100 BLIST[N]←0;BLIST[N+1]←MEM[D-2];
01200 BLIST[N+2]←MEM[D-1];N←3+(CDAD←N);END;
01300 DAD$(CDAD,CFR);
01400 END;
01500
01600 SUBR NOTSEEN;
01700 BEGIN
01800 CFR←MKNODE(FNUM);CT←MKCOPY(TRAM(CB));
01900 IF (POP←DAD(CB))∧¬CAMR THEN SEEIT(POP);
02000 START_CODE LABEL NCAM;
02100 HRRZ 1,CFR; HRRZ 2,CT;
02200 HRRM 2,6(1); HRRZ 2,CB;
02300 MOVE 2,FNUM; HRRM 2,4(1);
02400 HRLI 1,(1); MOVEM 2,7(1);
02500 SKIPN 3,I; HRRZ 3,N;
02600 ADD 3,BLIST; MOVEM 1,-1(3);
02700 HRRZ 1,CB; SKIPE CAMR;
02800 HRRZI 1,NCAM; JRST NCAM; "α"; 0;
02900 NCAM: MOVE 2,-1(1); MOVE 1,-2(1); MOVEM 1,(3);
03000 MOVEM 2,1(3); HRRZI 1,3;
03100 SKIPN I; ADDM 1,N; END;
03200 END;
03300
03400 SUBR ADNODE;
03500 BEGIN "ADNODE"
03600 CFR←MKNODE(FNUM);MVNUM$(FNUM,CFR);
03700 IF (POP←DAD(CB))∧¬CAMR THEN SEEIT(POP);
03800 CT←MKCOPY(TRAM(CB));TRAM$(CT,CFR);
03900 CW$(NFR,CFR);CCW$(PFR,CFR);
04000 CW$(CFR,PFR);CCW$(CFR,NFR);
04100 END "ADNODE";
04200
04300 SUBR FLIP(INTEGER NUM,INDX);
04400 BEGIN INTEGER PFRM,CFRM;
04500 PFRM←CFRM←NINK(BLIST[INDX]);
04600 IF SNUM(CFRM)<NUM THEN BEGIN
04700 DO CFRM←CW(CFRM) UNTIL SNUM(CFRM)≥NUM∨CFRM=PFRM;
04800 IF CFRM=PFRM THEN CFRM←CB;END;
04900 RETURN(CFRM);
05000 END;
05100
05200 SUBR SETUP;
05300 BEGIN
05400 IF (I←SEEN(CB)) THEN CFR←FLIP(FNUM,I)
05500 ELSE CFR←CB;
05600 NLINK$(CFR,CB);
05700 END;
00100 SUBR LOOK;
00200 BEGIN
00300 IF ¬(I←SEEN(CB))∨¬BLIST[I] THEN NOTSEEN
00400 ELSE BEGIN
00500 PFR←PINK(BLIST[I]);NFR←NINK(BLIST[I]);
00600 IF MVNUM(PFR)≤FNUM THEN BEGIN "ATEND"
00700 IF MVNUM(PFR)≠FNUM THEN
00800 IF MOVED(PFR) THEN BEGIN
00900 ADNODE;
01000 BLIST[I]←XWD(NINK(BLIST[I]),CFR);END
01100 ELSE MVNUM(FNUM,PFR)
01200 ELSE IF SNUM(PFR)=FNUM THEN COPTRM
01300 ELSE IF MOVED(PFR) THEN BEGIN
01400 ADNODE;
01500 BLIST[I]←XWD(NINK(BLIST[I]),CFR);
01600 NT←SNUM(PFR);MVNUM$(NT,PFR);END;
01700 END "ATEND"
01800 ELSE IF SNUM(NFR)≥FNUM THEN BEGIN "ATBEG"
01900 IF SNUM(NFR)≠FNUM THEN
02000 IF MOVED(NFR) THEN BEGIN
02100 ADNODE;
02200 BLIST[I]←XWD(CFR,BLIST[I]);END
02300 ELSE SNUM(NFR)←FNUM
02400 ELSE IF MVNUM(NFR)=FNUM THEN COPTRM
02500 ELSE IF MOVED(NFR) THEN BEGIN
02600 ADNODE;
02700 BLIST[I]←XWD(CFR,BLIST[I]);
02800 SNUM(NFR)←MVNUM(NFR);END;
02900 END "ATBEG"
03000 ELSE BEGIN "FDFRM"
03100 WHILE SNUM(PFR)≥FNUM DO PFR←CCW(PFR);
03200 NFR←CW(PFR);
03300 IF SNUM(NFR)=FNUM THEN
03400 IF MVNUM(NFR)=FNUM THEN COPTRM
03500 ELSE IF MOVED(PFR) THEN BEGIN
03600 ADNODE;SNUM(NFR)←MVNUM(NFR);END
03700 ELSE BEGIN
03800 MVNUM$(FNUM,PFR);SNUM(NFR)←MVNUM(NFR);END
03900 ELSE IF MVNUM(PFR)≤FNUM THEN
04000 IF MOVED(PFR) THEN
04100 IF MOVED(NFR) THEN BEGIN
04200 ADNODE;
04300 IF MVNUM(PFR)=FNUM THEN BEGIN
04400 NT←SNUM(PFR);MVNUM$(NT,PFR);END;END
04500 ELSE SNUM(NFR)←FNUM
04600 ELSE MVNUM$(FNUM,PFR)
04700 ELSE IF MOVED(PFR) THEN BEGIN
04800 NT←NFR;NFR←MKNODE(MVNUM(PFR));
04900 CT←MKCOPY(TRAM(PFR));TRAM$(CT,NFR);
05000 CW$(NT,NFR);CCW$(NFR,NT);
05100 NT←SNUM(NFR);MVNUM$(NT,NFR);ADNODE;END;
05200 END "FDFRM";END;
05300 END;
00100 SUBR GDEL(INTEGER T1,T2);
00200 START_CODE
00300 HRRZ 1,CFR; HRRZ 2,TMP;
00400 MOVE 3,-3(2); FDVR 3,RNOF; MOVEM 3,1(1);
00500 MOVE 3,-2(2); FDVR 3,RNOF; MOVEM 3,2(1);
00600 MOVE 3,-1(2); FDVR 3,RNOF; MOVEM 3,3(1);
00700 HRRZ 2,T1; HRRZ 3,T2;
00800 MOVE 4,-3(3); FSBR 4,-3(2); FDVR 4,RNOF; MOVEM 4,-3(1);
00900 MOVE 4,-2(3); FSBR 4,-2(2); FDVR 4,RNOF; MOVEM 4,-2(1);
01000 MOVE 4,-1(3); FSBR 4,-1(2); FDVR 4,RNOF; MOVEM 4,-1(1);
01100 END;
01200
01300 SUBR MKDEL(INTEGER Q1,Q2);
01400 BEGIN
01500 CT←TRAM(Q1);NT←TRAM(Q2);TMP←MKCOPY(CT);
01600 APTRAN(INTRAN(TMP),NT); CVTRMV(TMP);
01700 GDEL(CT,NT);KLNODE(TMP);
01800 END;
01900
02000 SUBR MOVEIT;
02100 BEGIN
02200 IF (CFR←NLINK(CB))≠CB∧MVNUM(CFR)≤FNUM THEN BEGIN
02300 IF MVNUM(CFR)=FNUM THEN BEGIN
02400 NFR←CW(CFR);
02500 IF SNUM(NFR)>FNUM THEN BEGIN
02600 RNOF←SNUM(NFR)-FNUM;
02700 IF CAMR THEN MKDEL(CFR,NFR)
02800 ELSE IF (POP←DAD(NFR)) THEN BEGIN
02900 CD←WO;
03000 DO CD←CW(CD) UNTIL
03100 BLIST[POP+1]=MEM[CD-2]∧BLIST[POP+2]=MEM[CD-1];
03200 BATT(CB,CD);
03300 IF (CDAD←NLINK(CD))≠CD∧MVNUM(CDAD)=FNUM THEN BEGIN
03400 NDAD←CW(CDAD);
03500 IF SNUM(NDAD)>FNUM THEN BEGIN INTEGER DTMP;
03600 DTMP←MKCOPY(TRAM(CDAD));
03700 APTRAN(INTRAN(DTMP),TRAM(NDAD));
03800 TMP←MKCOPY(TRAM(CFR));
03900 APTRAN(TMP,DTMP);
04000 KLNODE(DTMP);
04100 DTMP←MKCOPY(TMP);
04200 APTRAN(INTRAN(TMP),TRAM(NFR));
04300 CVTRMV(TMP);
04400 GDEL(DTMP,TRAM(NFR));
04500 KLNODE(TMP);KLNODE(DTMP);END;END
04600 ELSE MKDEL(CFR,NFR);END
04700 ELSE IF DAD(CB) THEN BEGIN
04800 BDET(CB);MKDEL(CFR,NFR);END
04900 ELSE MKDEL(CFR,NFR);END
05000 ELSE BEGIN NLINK$(CB,CB);RETURN(0);END;END;
05100 TRANSL(CB,XWC(CFR),YWC(CFR),ZWC(CFR));
05200 ROTATE(XWD(-2,-CB),IY(CFR),IZ(CFR),JX(CFR));
05300 TMP←CW(CFR);
05400 IF SNUM(TMP)=FNUM+1 THEN NLINK$(TMP,CB);END;
05500 END;
05600
05700 α DTMP←MKCOPY(TRAM(PDAD));
05800 α APTRAM(INTRAM(DTMP),TRAM(NDAD));
05900
06000 α TMP←MKCOPY(TRAM(PFR));
06100 α APTRAM(TMP,DTMP);
06200 α KLNODE(DTMP);
06300
06400 α DTMP←MKCOPY(TMP);
06500 α APTRAM(INTRAM(TMP),TRAM(NFR));
06600 α CVTRMV(TMP);
06700
06800 α GDEL(DTMP,TRAM(NFR));
06900
07000 α KLNODE(TMP);
07100 α KLNODE(DTMP);
07200
07300
07400 SUBR MVCAM;
07500 BEGIN
07600 TMP←0;CAMR←CB←NCCW(WO);MOVEIT;CAMR←0;
07700 IF TMP THEN BEGIN
07800 FO←JX(CB);
07900 JX(CB)←FO+(FOCAL(TMP)-FO)/(SNUM(TMP)-FNUM);
08000 IF JX(CB)>0 THEN BEGIN
08100 FO←JX(CB)/FO;XWC(CB)←XWC(CB)*FO;
08200 YWC(CB)←YWC(CB)*FO;ZWC(CB)←ZWC(CB)*FO;END
08300 ELSE JX(CB)←FO;END;
08400 END;
00100 MKUNIV;GEODPY;WO←DAD(UNIVERSE);N←FNUM←1;
00200 WHILE TRUE DO BEGIN "COMS"
00300
00400 EXTERNAL INTEGER ENTERS;
00500 GEOMED;
00600 IF ENTERS≠-1 THEN USERERR(1,1,"Some GEOMED routine exited wrong");
00700 CI←INCHRW;
00800
00900 IF CI="A" THEN BEGIN "ADFRM"
01000 OUTSTR("
01100 FRM # "&CVS(FNUM)&" FRM # = ");STR←INCHWL;
01200 IF LENGTH(STR)≠0 THEN FNUM←INTSCAN(STR,CHR);
01300 CAMR←CB←NCCW(WO);LOOK;
01400 IF CFR THEN FOCAL(CFR)←JX(CB);
01500 CAMR←0;CB←WO;
01600 WHILE (CB←CW(CB))≠WO DO LOOK;
01700 END "ADFRM";
01800
01900 IF CI="R"∨CI="M"∨CI="P" THEN BEGIN "MKMOVI"
02000 OUTSTR("
02100 FRM # "&CVS(FNUM)&" START # = ");STR←INCHWL;
02200 IF LENGTH(STR)≠0 THEN FNUM←INTSCAN(STR,CHR);
02300 OUTSTR(" END # = ");STR←INCHWL;
02400 IF LENGTH(STR)≠0 THEN BEGIN
02500 TF←INTSCAN(STR,CHR);TF←TF+FNUM;
02600 CAMR←CB←NCCW(WO);SETUP;CAMR←0;CB←WO;
02700 WHILE WO≠(CB←CW(CB)) DO SETUP;
02800 WHILE FNUM<TF DO BEGIN "FRAMES"
02900 CASE CI OF BEGIN
03000 ["R"] GEODPY;
03100 ["P"] BEGIN GEODPY;PLTO;END;
03200 ["M"] BEGIN SHOW2(0,0);PLTO;END END;
03300 MVCAM;CB←WO;
03400 WHILE WO≠(CB←CW(CB)) DO MOVEIT;
03500 FNUM←FNUM+1;END "FRAMES";
03600 FNUM←FNUM-1;END;
03700 END "MKMOVI";
03800
03900 END "COMS";
04000
04100 END "ANIMED";